home *** CD-ROM | disk | FTP | other *** search
/ Power Programmierung / Power-Programmierung (Tewi)(1994).iso / magazine / pctchnqs / 1991 / number3 / huffman.pas < prev    next >
Pascal/Delphi Source File  |  1990-09-14  |  9KB  |  291 lines
  1.  {$M 32767,0,655360}
  2.  Program Huffman; {$R-}
  3.  
  4. {  Huffman compression routine.
  5.    Uses up to 15 bits for compression.
  6.  
  7.    For Turbo Pascal 5.5
  8.    Copyright (c) 1989, Rick Gessner.  }
  9.  
  10.  Uses Crt;
  11.  
  12.  Const
  13.    VideoMem  = $B800;     {set=$B000 if your screen is mono }
  14.  Type
  15.    TableType = Array[0..255] of Word;{one for each valid byte value }
  16.    BuffType  = Array[1..1] of Byte;  {used to pass conformant arrays}
  17.  
  18.  {-----------------------------------------------------------------}
  19.  
  20.  FUNCTION Bit_Count(Val: Word): Word;
  21.  Var I : Integer;
  22.  Begin
  23.    I:=0;             { The purpose of this routine is to determine }
  24.    While Val>0 do    { the significant number of bits required to  }
  25.    Begin             { represent the given value.                  }
  26.      Inc(I);         { It will be used by Compress and Decompress  }
  27.      Val:=Val Shr 1; { to determine how many bits to write to the  }
  28.    end;              { output buffer for each huffman code.        }
  29.    Bit_Count:=I;
  30.  end; {Bit count}
  31.  
  32.  {-----------------------------------------------------------------}
  33.  
  34.  FUNCTION Create_Huffman_Code_Table(Var CodeTable,Index: TableType;
  35.           TheSize,Count: Word): Boolean;
  36.                 {Returns false if it overruns the 15 Bit limitation}
  37.  Type
  38.    NodeRec = Record
  39.                Value: Real;
  40.                Next : Integer;
  41.              end;
  42.  Var  TempVal  : Real;
  43.       Start    : Integer;
  44.       IncrVal,
  45.       WorkVal,
  46.       BitNum,
  47.       NodeCount,
  48.       I,Item   : Word;
  49.       NodeList : Array[0..1000] of NodeRec;
  50.  
  51. PROCEDURE Combine(Node1,Node2: Integer);
  52. Begin
  53.   Inc(NodeCount);
  54.   { Add the node values: }
  55.   NodeList[NodeCount].Value := NodeList[Node1].Value +
  56.                                NodeList[Node2].Value;
  57.   { Point node up: }
  58.   Nodelist[Node1].Next := NodeCount*(Ord(Node1>1)*-1);
  59.   { Set this node to top of list: }
  60.   NodeList[Node2].Next := NodeCount;
  61. end; {Combine}
  62.  
  63. PROCEDURE Build_SubTree(NodePos: Integer; Max: Real);
  64. Begin
  65.   Repeat
  66.     Combine(Start,Start-1);       {Combine 2 successive nodes}
  67.     Dec(Start,2);
  68.     If (NodePos<>NodeCount) then
  69.       Begin
  70.         If (NodeList[NodePos].Value>NodeList[NodeCount].Value)
  71.             and (Start>=1) then
  72.               Build_SubTree(NodeCount,NodeList[NodePos].Value);
  73.         Combine(NodePos,Nodecount);
  74.         NodePos := NodeCount;
  75.       end
  76.     else
  77.       If (NodeList[NodePos].Value<=NodeList[Start].Value)
  78.         then
  79.           Begin
  80.             { Combine current node with 1st node: }
  81.             Combine(NodePos,Start);
  82.             Dec(Start);
  83.             NodePos := NodeCount;
  84.           end;
  85.   Until (NodeList[NodeCount].Value>=Max) or (Start<1);
  86. end; {Build substree}
  87.  
  88. Begin
  89.   FillChar(NodeList,Sizeof(NodeList),0);
  90.   Create_Huffman_Code_Table := False;
  91.   { Here, put probability of each code in table in its }
  92.   {  correspondiong node: }
  93.   For Item:=1 to Count do
  94.     NodeList[Item].Value:=CodeTable[Index[Item]]/TheSize;
  95.   NodeCount := Count;
  96.   Start     := Count;
  97.   Build_SubTree(Succ(NodeCount),1);  {Make the huffman codes }
  98.   For Item:=1 to Count do
  99.     Begin
  100.       I:=Item; BitNum:=0;
  101.       TempVal := 0; WorkVal:=0; IncrVal:=1;
  102.       Repeat
  103.         If (NodeList[i].Value<>TempVal) and
  104.            (NodeList[i].value<>0)
  105.         then
  106.           Begin
  107.             If NodeList[i].Next<0 then Inc(WorkVal,IncrVal);
  108.             TempVal := NodeList[i].Value;
  109.             IncrVal := IncrVal shl 1; { Travel down the nodes, }
  110.             Inc(BitNum);              {  tracking the current bit }
  111.           end;                        {  pattern until you hit a }
  112.         I:=Abs(NodeLIst[i].Next);     {  terminal node.}
  113.       Until NodeList[I].Next=0;
  114.       If BitNum > 15 then exit;       { Jump out, were outta space }
  115.       Inc(WorkVal,IncrVal);
  116.       { Assign this code to the current entry: }
  117.       CodeTable[Index[Item]]:=WorkVal;
  118.     end;
  119.       Create_Huffman_Code_Table := True;
  120.  end; {Create Huffman code Table}
  121.  
  122.  {-----------------------------------------------------------------}
  123.  
  124.  FUNCTION Create_Freq_Index(Var CodeTable,
  125.                                 FreqIndex: TableType) : Word;
  126.  
  127.  Var
  128.    I,J,K,CodeTableCount : Integer;
  129.  
  130.  Begin
  131.    FillChar(FreqIndex,SizeOf(FreqIndex),0);   {Init freq. index}
  132.    CodeTableCount := 0;
  133.    { This is really just a routine that creates an index }
  134.    {  into CodeTable: }
  135.    For I:=0 to 255 do If CodeTable[i]<>0 then
  136.      Begin
  137.        J:=1;
  138.        While (J<=CodeTableCount) and
  139.              (CodeTable[FreqIndex[j]]>CodeTable[i]) do Inc(J);
  140.        If FreqIndex[j]<>0 then
  141.        Move(FreqIndex[j],FreqIndex[j+1],
  142.             Succ(CodeTableCount-J)*SizeOf(Freqindex[1]));
  143.        FreqIndex[j]:=i;
  144.        Inc(CodeTableCount);
  145.      end;
  146.    Create_Freq_Index := CodeTableCount;
  147.  end; {Create freq index}
  148.  
  149.  {-----------------------------------------------------------------}
  150.  
  151. FUNCTION Compress(Var Buffer1,Buffer2; Var CodeTable : TableType;
  152.                    Var TheSize: Word): Boolean;
  153.  
  154. Var OrigBuffer      : BuffType Absolute Buffer1;
  155.     NewBuff         : BuffType Absolute Buffer2;
  156.     CodeTableIndex  : TableType;
  157.     NewBuffBitNum,
  158.     BitNum,
  159.     OrigBuffPos,
  160.     NewBuffPos,
  161.     CodeCount,I     : Word;
  162.  
  163. Begin
  164.   FillChar(CodeTable,SizeOf(CodeTable),0);   {Init freq. table}
  165.   { Build frequency table: }
  166.   For I:=1 to TheSize do Inc(CodeTable[OrigBuffer[i]]);
  167.   { Create table index: }
  168.   CodeCount := Create_Freq_Index(CodeTable,CodeTableIndex);
  169.   If Create_Huffman_Code_Table(CodeTable,CodeTableIndex,
  170.                                TheSize,CodeCount)
  171.   then  {The index is no longer needed}
  172.     Begin
  173.       NewBuffPos    := 1;        { Notice that the code images are }
  174.       NewBuffBitNum := 0;        {  being written backwards.       }
  175.       NewBuff[NewBuffPos]:=0;
  176.       For OrigBuffPos:=1 to TheSize do
  177.         Begin
  178.           For BitNum:=Bit_Count(CodeTable[OrigBuffer[OrigBuffPos]])
  179.             downto 1 do
  180.               Begin
  181.                 NewBuff[NewBuffPos] := NewBuff[NewBuffPos] +
  182.                         (((CodeTable[OrigBuffer[OrigBuffPos]]
  183.                 Shr Pred(BitNum)) and 1) Shl NewBuffBitNum);
  184.                 If NewBuffBitNum<7 then Inc(NewBuffBitNum) else
  185.                   Begin
  186.                     NewBuffBitNum:=0; Inc(NewBuffPos);
  187.                     NewBuff[NewBuffPos]:=0;
  188.                   end;
  189.               end;
  190.            end;
  191.           TheSize := NewBuffPos;
  192.       end else Compress:=False;
  193.  end; {Compress}
  194.  
  195.  {------------------------------------------------------------------}
  196.  
  197. PROCEDURE Decompress(Var Buffer1,Buffer2; Var CodeTable: TableType;
  198.                       Var Size: Word);
  199.  
  200. Var  OrigBuff        : BuffType absolute Buffer1;
  201.      NewBuff         : BuffType absolute Buffer2;
  202.      CodeIndex       : TableType;
  203.      BitNum,
  204.      BuffPos,
  205.      NextCode,
  206.      CodeCount       : Word;
  207.  
  208.  
  209. { Compare Value to Huffman code}
  210. { table using a binary search. }
  211. { If no match, return 0, else  }
  212. { return proper byte value.     }
  213.  
  214. FUNCTION Find_Encoded_Val(Var Value: Word): Byte;
  215.  
  216. Var I : Integer;
  217.  
  218. Begin
  219.   Find_Encoded_Val:=0;
  220.   If Value>=CodeTable[CodeIndex[CodeCount]] then
  221.     For I:=1 to CodeCount do
  222.       If CodeTable[CodeIndex[i]]=Value then
  223.         Begin
  224.           Find_Encoded_Val:=CodeIndex[i]; exit;
  225.         end;
  226. end; {Find_Encoded_Val}
  227.  
  228. Begin
  229.   { Make code table index: }
  230.   CodeCount := Create_Freq_Index(CodeTable,CodeIndex);
  231.   BuffPos := 1; {Position in input buffer}
  232.   BitNum  := 1; {Current bit number of current byte in input buffer}
  233.   Size    := 0; {Init reported size of return buffer}
  234.   Repeat
  235.     NextCode:=0;
  236.     Inc(Size);
  237.     Repeat
  238.       NextCode:= (NextCode shl 1) + (OrigBuff[BuffPos] and 1);
  239.       OrigBuff[BuffPos]:=OrigBuff[BuffPos] shr 1;
  240.       If BitNum<8 then Inc(BitNum) else
  241.         Begin
  242.           BitNum:=1; Inc(BuffPos);
  243.         end;
  244.       NewBuff[Size]:=Find_Encoded_Val(NextCode);
  245.     Until (NewBuff[Size]<>0) or (NextCode=0);
  246.   Until NextCode=0;
  247. end; {Decompress}
  248.  
  249. {-----------------------------------------------------------------}
  250.  
  251. PROCEDURE Test_It_Out;
  252.  
  253. Const ScreenSize = 160*20;  {20 lines of the screen: char+Attr}
  254.  
  255. Var   OldBuffer,
  256.        NewBuffer        : Array[1..4000] of byte;
  257.        CompressionTable : TableType;
  258.        TheSize          : Word;
  259.  
  260. Begin
  261.   { Write 20 strings to screen: }
  262.   For TheSize:=1 to 20 do Writeln('Hello there: ',TheSize);
  263.   { Grab the screen image: }
  264.   Move(Mem[VideoMem:0],OldBuffer,ScreenSize); 
  265.   Writeln('This is the original image, press a key to test...');
  266.   If Readkey<>Chr(0) then ClrScr;
  267.   TheSize := ScreenSize;
  268.   { Compress the buffer: }
  269.   Writeln('Compressing...');
  270.   If Compress(OldBuffer,NewBuffer,CompressionTable,TheSize) then
  271.     Begin
  272.       FillChar(OldBuffer,SizeOf(OldBuffer),0);
  273.       Writeln('Decompressing...');
  274.       { Decompress buffer: }
  275.       Decompress(NewBuffer,OldBuffer,CompressionTable,TheSize);
  276.       Writeln('Done, press a key...');
  277.       If Readkey=' ' then;
  278.       ClrScr;
  279.       { Redisplay buffer on screen: }
  280.       Move(OldBuffer,Mem[VideoMem:0],3200);
  281.       Readln
  282.     end;
  283. end; {Test it out}
  284.  
  285. {------------------------------------------------------------------}
  286.  
  287. Begin
  288.   ClrScr;
  289.   Test_It_Out;
  290. end. {Huffman program}
  291.